home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / comp / back_end / assign.t next >
Encoding:
Text File  |  1990-06-15  |  10.3 KB  |  302 lines
  1. (herald test)
  2.  
  3. ;;+  FIx for locatives
  4.  
  5. (define (introduce-cell var)
  6.   (let ((node (variable-binder var))
  7.         (new-var (create-variable (variable-name var))))
  8.     (set (variable-rep new-var) 'assigned)
  9.     (hack-references var new-var)
  10.     (let-nodes ((call (($ primop/make-cell) 1 (^ cont1)))
  11.         (cont1 (() (v new-var))
  12.           (($ primop/set-location) 1
  13.                (^ cont2) ($ primop/cell-value) (* var) (* new-var)))
  14.         (cont2 (#f) ()))
  15.            (insert-call call cont2 node))))
  16.  
  17. (define (cell-collapsable? var)
  18.   (every? (lambda (ref)
  19.             (or (and (eq? (node-role ref) (call-arg 3))
  20.                      (primop-ref? (call-proc (node-parent ref))
  21.                                   primop/contents-location))
  22.                 (and (eq? (node-role ref) (call-arg 4))
  23.                      (primop-ref? (call-proc (node-parent ref))
  24.                                   primop/set-location))))
  25.           (variable-refs var)))
  26.  
  27. (define (sort-vars vars)
  28.   (iterate loop ((vars vars) (pointer '()) (scratch '()))
  29.     (cond ((null? vars)
  30.            pointer)
  31.            (else
  32.             (loop (cdr vars) (cons (car vars) pointer) scratch)))))
  33.  
  34. (define-constant (assigned-var? var)
  35.   (eq? (variable-rep var) 'assigned))
  36.  
  37. (define (stack-cell? var)
  38.   (and (eq? (variable-rep var) 'assigned)
  39.        (not (variable-definition var))))
  40.  
  41. (define (consed-heap-cell? var)
  42.   (and (eq? (variable-rep var) 'assigned)
  43.        (eq? (variable-definition var) 'consed-heap-cell)))
  44.  
  45. (define (heap-cell? var)
  46.   (and (eq? (variable-rep var) 'assigned)
  47.        (eq? (variable-definition var) 'heap-cell)))
  48.  
  49. (define (close-analyze-body node up henv hvia)
  50.   (cond ((and (primop-node? (call-proc node))
  51.               (eq? (primop-value (call-proc node)) primop/Y))
  52.      (let ((cont ((call-arg 1) node)))
  53.        (if (lambda-node? cont)
  54.            (walk (lambda (var) 
  55.                (set (variable-definition var) 'consed-heap-cell))
  56.              (lambda-live cont)))
  57.        (really-close-analyze-body
  58.         (cons cont (call-args (lambda-body ((call-arg 2) node))))
  59.         up henv hvia)))
  60.         (else
  61.          (really-close-analyze-body (call-proc+args node)
  62.                                     up henv hvia))))
  63.  
  64. (define (close-analyze-label node heapenv heapvia)
  65.   (let* ((assigned? (any? assigned-var? (lambda-live node)))
  66.      (live (filter (lambda (x) (not (heap-cell? x)))
  67.                (lambda-live node)))
  68.          (need-contour? (or (eq? (lambda-env node) 'needs-link) assigned?)))
  69.     (set (lambda-env node) (create-join-point live heapvia need-contour? node))
  70.     (if (fully-recursive? node)
  71.     (walk (lambda (var) 
  72.         (set (variable-definition var) 'consed-heap-cell))
  73.           live))
  74.     (close-analyze-body (lambda-body node) heapvia '() heapvia)))
  75.  
  76. (define (close-analyze-heap cics live up henv hvia)
  77.   (let* ((cic-vars (map lambda-self-var cics))
  78.          (live (set-difference live cic-vars))
  79.          (global? (or (memq? hvia live)
  80.                       (any? (lambda (node)
  81.                               (eq? (lambda-env node) 'unit-internal-closure))
  82.                             cics)))
  83.          (inter (intersection live henv))
  84.      (link (if (or global? inter)
  85.            hvia 
  86.            nil))
  87.      (delta (set-difference (delq! hvia live) henv))
  88.      (assigned? (any? assigned-var? inter)))
  89.     (if (or global? (cdr inter) assigned?)
  90.     (create-closure link cic-vars delta nil up)
  91.     (create-closure nil cic-vars live nil up))
  92.     (walk (lambda (var) 
  93.         (if (any? (lambda (cic)
  94.             (memq? var (lambda-live (node-parent (node-parent cic)))))
  95.               cics)
  96.         (set (variable-definition var) 'consed-heap-cell)))
  97.       (filter! assigned-var? delta))            ;too tough
  98.     (walk (lambda (cic)
  99.             (cond ((object-lambda? cic)
  100.                    (destructure (((#f proc #f . methods) 
  101.                                   (call-args (lambda-body cic))))
  102.                      (walk (lambda (method)                     
  103.                               (set (lambda-env method) (lambda-env cic))
  104.                               (close-analyze-body (lambda-body method)
  105.                                                   up
  106.                                                   live
  107.                                                   (lambda-self-var cic)))
  108.                            (cons proc methods))))
  109.                   (else
  110.                    (close-analyze-body (lambda-body cic)
  111.                        up
  112.                                        live
  113.                                        (lambda-self-var cic)))))
  114.           cics)))
  115.  
  116.  
  117.  
  118. (define (cell-collapse var)
  119.   (cond ((null? (variable-definition var))
  120.      (set (variable-definition var) 'heap-cell))
  121.     (else
  122.      (set (variable-definition var) 'consed-heap-cell))))
  123.  
  124. (define (compute-label-arg-specs node label join p-ok? stack-ok? stack?)
  125.   (receive (formals actuals) (if (continuation? label)
  126.                                  (return (lambda-variables label)
  127.                                          (call-args node))
  128.                                  (return (cdr (lambda-variables label))
  129.                                          (cdr (call-args node))))
  130.   (iterate loop ((actuals actuals)
  131.          (formals formals)
  132.          (arg-specs '())
  133.          (env (join-point-env join))
  134.          (env-specs '())
  135.          (eleft '())
  136.          (regs (cond (p-ok?
  137.                   (list AN))
  138.                  ((and stack? stack-ok?)
  139.                   (list *first-stack-register* AN))
  140.                  (else
  141.                   (list P AN)))))
  142.     (cond ((null? formals)
  143.        (cond ((null? env)
  144.           (iterate loop ((env-specs env-specs)
  145.                  (env eleft)
  146.                  (regs regs))
  147.                (cond ((null? env)
  148.                   (maybe-set-lambda-max regs)
  149.                   (return arg-specs env-specs))
  150.                  (else
  151.                   (let ((reg (cond ((not (consed-heap-cell? (car env)))
  152.                             (get-free-register regs
  153.                                        p-ok?
  154.                                        '#t '#t
  155.                                        '#t))
  156.                            ((ok-next-register? (car env)
  157.                                        regs
  158.                                        label
  159.                                        stack-ok?
  160.                                        stack?
  161.                                        '#t))
  162.                            (else
  163.                             (get-free-register regs
  164.                                        p-ok?
  165.                                        stack-ok?
  166.                                        stack?
  167.                                        '#t)))))
  168.                     (loop (cons (cons reg (car env)) env-specs)
  169.                       (cdr env)
  170.                       (cons reg regs)))))))
  171.          ((and (consed-heap-cell? (car env))
  172.                (in-ok-register? (car env) regs stack-ok? stack? '#t))
  173.           => (lambda (reg)
  174.                (loop actuals
  175.                  formals
  176.                  arg-specs
  177.                  (cdr env)
  178.                  (cons (cons reg (car env)) env-specs)
  179.                  eleft
  180.                  (cons reg regs))))
  181.          (else
  182.           (loop actuals
  183.             formals
  184.             arg-specs
  185.             (cdr env)
  186.             env-specs
  187.             (cons (car env) eleft)
  188.             regs))))
  189.           (else
  190.        (let ((reg (cond ((and (reference-node? (car actuals))
  191.                   (in-ok-register?
  192.                    (reference-variable (car actuals)) regs
  193.                    stack-ok?
  194.                    stack?
  195.                    '#f)))
  196.                 ((and (car formals)
  197.                   (ok-next-register? (car formals)
  198.                              regs label stack? stack-ok? '#f)))
  199.                 (else (get-free-register regs p-ok? stack-ok? 
  200.                              stack? '#f)))))
  201.          (loop (cdr actuals)
  202.            (cdr formals)
  203.            (cons reg arg-specs)
  204.            env
  205.            env-specs
  206.            eleft
  207.            (cons reg regs))))))))
  208.  
  209.  
  210. (define (generate-make-cell node)
  211.   (let* ((cont ((call-arg 1) node))
  212.      (reg (get-target-register node cont nil nil)))
  213.     (cond ((and (lambda-node? cont)
  214.         (not (consed-heap-cell? (car (lambda-variables cont)))))
  215.        (mark-continuation node (get-stack-slot node)))
  216.           (else
  217.            (free-register node AN)
  218.            (generate-move (machine-num 4) scratch)               ; 1 slot
  219.            (generate-move (machine-num header/cell) AN)
  220.            (generate-slink-call slink/make-extend)  
  221.            (mark-continuation node AN)))))
  222.  
  223. (define (generate-set-fixed-accessor node)
  224.   (destructure (((#f type value loc) (call-args node)))
  225.     (let* ((prim (leaf-value type))
  226.        (loc (leaf-value loc))
  227.            (do-it 
  228.             (lambda (access)
  229.               (cond ((or (neq? prim primop/cell-value)
  230.              (consed-heap-cell? loc))
  231.                      (let ((reg (->register node loc)))
  232.                        (emit risc/store 'l
  233.                  access
  234.                  (reg-offset reg (primop.location-specs prim)))))
  235.                     ((stack-cell? loc)
  236.              (cond ((and (not (register-loc loc)) (temp-loc loc))
  237.                 => (lambda (temp)
  238.                  (emit risc/store 'l access temp)))
  239.                (else
  240.                 (bug "Assigned var not on stack or in register ~s" loc))))
  241.             ((register-loc loc)
  242.              (bug "Assigned heap cell in register ~s" loc))
  243.             (else
  244.              (let ((hl (and (assigned-var-in-heap?
  245.                      node
  246.                      (lambda-self-var *heap-env*)
  247.                      loc)
  248.                     (lookup node loc (variable-binder loc)))))
  249.                (if hl (emit risc/store 'l access hl))
  250.                (cond ((temp-loc loc)
  251.                   => (lambda (loc)
  252.                    (emit risc/store 'l access loc))))))))))
  253.              
  254.              (let ((reg (cond ((lambda-node? value)
  255.                    (access/make-closure node value))
  256.                   (else
  257.                    (->register node (leaf-value value))))))
  258.                (lock reg)
  259.                (do-it reg)
  260.                (unlock reg)))))
  261.  
  262. (define (generate-fixed-accessor node)
  263.   (destructure (((cont type loc) (call-args node)))
  264.    (if (or (leaf-node? cont) (used? (car (lambda-variables cont))))   
  265.          (let* ((type (leaf-value type))
  266.                 (base (leaf-value loc)))
  267.            (cond ((or (neq? type primop/cell-value)
  268.                        (consed-heap-cell? base))
  269.                   (let* ((reg (->register node base))
  270.              (target (get-target-register node cont reg nil)))
  271.                     (emit risc/load 'l (reg-offset reg (primop.location-specs type))
  272.                                    target)
  273.             (mark-continuation node target)))
  274.          ((register-loc base)
  275.           (bug "Assigned var not on stack or in register ~s" base))
  276.          ((temp-loc base)
  277.           => (lambda (temp)
  278.                (lock temp)
  279.                (let ((target (get-target-register node cont nil nil)))
  280.              (unlock temp)
  281.              (generate-move temp target)
  282.              (mark-continuation node target))))
  283.          (else
  284.           (let ((hl (lookup node base (variable-binder base))))
  285.             (protect-access hl)
  286.             (let ((target (get-target-register node cont nil nil)))
  287.               (release-access hl)
  288.               (generate-move hl target)
  289.               (mark-continuation node target)))))))))
  290.  
  291.  
  292. (define (assigned-var-in-heap? node contour value)
  293.   (iterate loop ((env (get-env contour)) (contour contour)) 
  294.     (let* ((closure (environment-closure env))
  295.        (a-list (closure-env closure))
  296.        (current-offset (environment-cic-offset env)))
  297.       (cond ((assq value a-list) '#t)
  298.             ((neq? closure *unit*)
  299.              (loop (get-env (caadr a-list)) (caadr a-list)))
  300.             (else '#f)))))
  301.  
  302.